Developer CD Series 1992 June: ROMin Holiday/ADC Developer CD (1992-06) (''ROMin Holiday'')_iso/Developer Connection - 06-1992.iso/Development Platforms/HyperCard Related/XCMDs & XFCNs/StackToPICSFile 1.1/StackToPICSFile.p

Text File | 1991-04-03 | 9.9 KB | 384 lines | [TEXT/MPS ]

{$R-}
{$S StackToPICSFile }

{
    StackToPICSFile(FileName, CreatorType)

    This XFCN makes a PICS file of the current Hypercard stack’s cards.

    A PICS file is merely a resource file with a consecutively-numbered series of
    PICT resources, beginning with resource number 128.  Normally, a PICS file can
    have frame-differenced PICTs, but this XFCN does not create frame-differenced
    images.  Instead, each PICT is a full image of the card it came from.

    The optional parameter CreatorType is a four-character string
    which will be the creator type of the file.  This will allow the file
    to be double-clicked to invoke the corresponding application.  The
    default value is '????' -- which means no application.

    If the XFCN is successful, then empty is returned, otherwise the return value
    is an error message.

    How does it work?  It goes to each each card and simulates the user holding down
    the option key while selecting "Copy Card" (which places a full-size PICT image
    of the card onto the clipboard).  Then, each PICT in succession is written to the
    file.

}

UNIT DummyUnit;

INTERFACE

    USES {* ToolIntf, PackIntf, *}
            ToolUtils, Resources, Packages,
            Menus, Events, TextEdit, HyperXCmd,
            OSIntf, Scrap, QuickDraw,

            PICSFileRoutines;

    PROCEDURE EntryPoint(paramPtr: XCmdPtr);

IMPLEMENTATION

    PROCEDURE StackToPICSFile(paramPtr: XCmdPtr);
    FORWARD;

    PROCEDURE EntryPoint(paramPtr: XCmdPtr);
    BEGIN
        StackToPICSFile(paramPtr)
    END { entrypoint } ;


    PROCEDURE StackToPICSFile(paramPtr: XCmdPtr);

    CONST

    MinParams =        1;
    MaxParams =        2;

    TYPE

    ParamArray =        PACKED ARRAY [1..MaxParams] OF Str255;

    VAR

    ParamStrings:            ParamArray;

    FileNameParam:            Str255;
    CreatorTypeParam:        OSType;

    fileRefNum:                Integer;

    myErr:                    Integer;
    ErrorMessage:            Str255;


        PROCEDURE ExitWithMessage(aString:    Str255);
        BEGIN
            WITH paramPtr^ DO BEGIN
                returnValue := PasToZero(paramPtr, aString);
                EXIT(StackToPICSFile);
            END;
        END;

        PROCEDURE ExitWithError(aString: Str255);
        BEGIN
            ExitWithMessage(concat('•••••••• Error: ', aString, '.'));
        END;

        FUNCTION StackVersionLaterThan(aVersionString: Str31): Boolean;
        VAR
            Expression:            Str255;
            EvalResult:            Handle;
            ResultString:        Str255;

        BEGIN

            StackVersionLaterThan := FALSE;

            Expression := concat('item 4 of the version of this stack >= ',
                                        aVersionString);

            EvalResult := EvalExpr(paramPtr, Expression);

            ZeroToPas(paramPtr, EvalResult^, ResultString);

            IF (StrToBool(paramPtr, ResultString)) THEN
                StackVersionLaterThan := TRUE;
        END;


        FUNCTION NumberOfCards: Integer;
        VAR
            Expression:            Str255;
            EvalResult:            Handle;
            ResultString:        Str255;

        BEGIN
            NumberOfCards := 0;

            Expression := concat('the number of cards in this stack');
            EvalResult := EvalExpr(paramPtr, Expression);

            ZeroToPas(paramPtr, EvalResult^, ResultString);

            NumberOfCards := LoWord(StrToNum(paramPtr, ResultString));

        END;

        FUNCTION GotoCard(CardNum: Integer): Boolean;
        VAR
            CardNumString:        Str255;
            Expression:            Str255;

        BEGIN
            GotoCard := FALSE;

            NumToStr(paramPtr, CardNum, CardNumString);
            Expression := concat('go to card ', CardNumString);

            {* Execute the hypertalk command to go to the card *}
            SendCardMessage(paramPtr, Expression);

            GotoCard := TRUE;

        END;

        FUNCTION GetPICTfromClipboard(ThePict: PicHandle; VAR ErrorMessage: Str255): Boolean;
        VAR
            PictSize:                Integer;
            ScrapOffset:            LONGINT;
        BEGIN
            GetPICTfromClipboard := FALSE;

            PictSize := GetScrap(Handle(ThePict), 'PICT', ScrapOffset);
            IF (PictSize = 0) THEN
            BEGIN
                ErrorMessage := 'Pict on clipboard was of zero size';
                Exit(GetPICTfromClipboard);
            END;

            IF (PictSize < 0)
            THEN
            BEGIN
                IF (PictSize = NoTypeErr) THEN
                    BEGIN
                        ErrorMessage := ('No data of type PICT on clipboard');
                        Exit(GetPICTfromClipboard);
                    END
                ELSE
                    BEGIN
                        ErrorMessage := ('Unknown error while getting PICT');
                        Exit(GetPICTfromClipboard);
                    END;
            END;

            GetPICTfromClipboard := TRUE;
        END;

        FUNCTION GetMenuItemCommandKey(ItemName: Str255; MenuName: Str255): Char;
        VAR
            Expression:            Str255;
            EvalResult:            Handle;
            ResultString:        Str255;
        BEGIN
            Expression := concat('the cmdChar of menuitem "', ItemName, '" of menu "', MenuName, '"');
            EvalResult := EvalExpr(paramPtr, Expression);

            ZeroToPas(paramPtr, EvalResult^, ResultString);

            IF (Length(ResultString) = 0) THEN
                GetMenuItemCommandKey := Char(0)
            ELSE
                GetMenuItemCommandKey := ResultString[1];
        END;

        PROCEDURE SetMenuItemCommandKey(ItemName: Str255; MenuName: Str255; KeyName: Char);
        VAR
            Expression:            Str255;
        BEGIN
            Expression := concat('set the cmdChar of menuitem "', ItemName, '" of menu "', MenuName, '" to ');
            IF (KeyName = Char(0)) THEN
                Expression := concat(Expression, 'empty')
            ELSE
                Expression := concat(Expression, '"', KeyName, '"');

            SendHCMessage(paramPtr, Expression);
        END;

        PROCEDURE TypeCharWithKeys(WhichChar: Char; ShiftKey, CmdKey, OptionKey: Boolean);
        VAR
            Expression:            Str255;
            AlreadyUsingOneKey:    Boolean;
        BEGIN
            Expression := concat('type "', WhichChar, '"');
            IF (ShiftKey OR CmdKey OR OptionKey) THEN
            BEGIN
                Expression := concat(Expression, ' with ');

                AlreadyUsingOneKey := FALSE;

                IF (ShiftKey) THEN
                BEGIN
                    IF (AlreadyUsingOneKey) THEN Expression := concat(Expression, ',');
                    Expression := concat(Expression, 'shiftKey');
                    AlreadyUsingOneKey := TRUE;
                END;

                IF (CmdKey) THEN
                BEGIN
                    IF (AlreadyUsingOneKey) THEN Expression := concat(Expression, ',');
                    Expression := concat(Expression, 'cmdKey');
                    AlreadyUsingOneKey := TRUE;
                END;

                IF (OptionKey) THEN
                BEGIN
                    IF (AlreadyUsingOneKey) THEN Expression := concat(Expression, ',');
                    Expression := concat(Expression, 'optionKey');
                    AlreadyUsingOneKey := TRUE;
                END;
            END;

            SendHCMessage(paramPtr, Expression);
        END;


        FUNCTION MakeTheFrames(fileRefNum: Integer; VAR ErrorMessage: Str255): Boolean;
        VAR

            OldMenuKey:            Char;
            NumCards:            Integer;
            Success:             Boolean;

            {* This is the callback routine that is passed to AddFramesToPICSFile.  It goes to the
                card specified by frameNum (i.e. CardNum), copies its image to the clipboard, and
                returns this image in theImage (a PicHandle);
                *}
            FUNCTION GetNumberedCardImage(CardNum: Integer; VAR theImage: PicHandle;
                                                VAR ErrorMessage: Str255): Boolean;
            VAR
                Success:            Boolean;
            BEGIN
                GetNumberedCardImage := FALSE;
                Success := TRUE;

                Success := Success AND GotoCard(CardNum);
                IF (NOT Success) THEN
                BEGIN
                    ErrorMessage := 'Problem while trying to move between cards';
                    Exit(GetNumberedCardImage);
                END;

                {* This is the same as typing Command-8 with the option key held down
                    -- and we will have already set up Command-8 to do Copy Card, so this
                    will cause the card to be copied, and a full-sized picture of the
                    card to be placed on the clipboard.  There should be a callback to
                    perform this function, but as of Hypercard 2.0, there was none
                    available.
                    *}
                TypeCharWithKeys(Char('8'), FALSE, TRUE, TRUE);

                Success := Success AND GetPICTfromClipboard(theImage, ErrorMessage);
                IF (NOT Success) THEN
                BEGIN
                    {* ErrorMessage was set by GetPICTfromClipboard *}
                    Exit(GetNumberedCardImage);
                END;

                GetNumberedCardImage := Success;
            END;

        BEGIN
            MakeTheFrames := FALSE;
            Success := TRUE;

            OldMenuKey := GetMenuItemCommandKey('Copy Card', 'Edit');
            SetMenuItemCommandKey('Copy Card', 'Edit', Char('8'));

            NumCards := NumberOfCards;

            Success := Success AND AddFramesToPICSFile(fileRefNum, NumCards,
                                            GetNumberedCardImage, ErrorMessage);

            {* Clean up *}
            SetMenuItemCommandKey('Copy Card', 'Edit', OldMenuKey);

            MakeTheFrames := Success;

        END;

        PROCEDURE ParseParams;
        VAR
            ParamNum:            integer;
        BEGIN
            WITH paramPtr^ DO
            BEGIN
                IF (paramCount < MinParams) THEN ExitWithError('Too few parameters');
                IF (paramCount > MaxParams) THEN ExitWithError('Too many parameters');

                ParamNum := 1; {* Required *}

                ZeroToPas(ParamPtr, Params[ParamNum]^, ParamStrings[ParamNum]);
                FileNameParam := ParamStrings[ParamNum];
                IF (FileNameParam = '') THEN ExitWithError('Empty file name');

                ParamNum := 2; {* Optional *}

                IF (paramCount >= ParamNum) THEN
                    BEGIN
                        ZeroToPas(paramPtr, params[ParamNum]^, ParamStrings[ParamNum]);
                        IF (length(ParamStrings[ParamNum]) <> 4)
                        THEN ExitWithError(concat('Bad creator type (not 4 characters): ',
                                ParamStrings[ParamNum]));

                        CreatorTypeParam[1] := ParamStrings[ParamNum][1];
                        CreatorTypeParam[2] := ParamStrings[ParamNum][2];
                        CreatorTypeParam[3] := ParamStrings[ParamNum][3];
                        CreatorTypeParam[4] := ParamStrings[ParamNum][4];
                    END
                ELSE
                    BEGIN
                        CreatorTypeParam := '????';
                    END;
            END;
        END;

    BEGIN {StackToPICSFile}

        ParseParams; {* May perform ExitWithError if parsing fails *}

        IF (StackVersionLaterThan('02000000') = FALSE) THEN
        BEGIN
            ExitWithError('StackToPICSFile can only convert stacks in Hypercard 2.0 format');
        END;

        IF (StartMakingPICSFile(FileNameParam, CreatorTypeParam, fileRefNum, ErrorMessage) <> TRUE) THEN
        BEGIN
            {* ErrorMessage is set by StartMakingPICSFile *}
            ExitWithError(ErrorMessage);
        END;

        IF (MakeTheFrames(fileRefNum, ErrorMessage) <> TRUE) THEN
        BEGIN
            IF (FinishMakingPICSFile(fileRefNum, ErrorMessage) <> TRUE) THEN
                        ExitWithError(ErrorMessage);
            {* ErrorMessage is set by MakeTheFrames *}
            ExitWithError(ErrorMessage);
        END;

        IF (FinishMakingPICSFile(fileRefNum, ErrorMessage) <> TRUE) THEN
        BEGIN
            {* ErrorMessage is set by FinishMakingPICSFile *}
            ExitWithError(ErrorMessage);
        END;

        ExitWithMessage('');

    END { StackToPICSFile} ;

END. { DummyUnit }